home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Diamond Collection / The Diamond Collection (Software Vault)(Digital Impact).ISO / cdr43 / xlibp202.zip / XLA2.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-18  |  35KB  |  1,381 lines
  1. Unit XLA2;
  2. {#F}
  3. {╔═══════════════════════════════════════════════════════════════════════════╗
  4. ║                                                                           ║
  5. ║        XLIB v2.0 - Graphics Library for Borland/Turbo Pascal 7.0          ║
  6. ║                                                                           ║
  7. ║               Tristan Tarrant - tristant@cogs.susx.ac.uk                  ║
  8. ║                                                                           ║
  9. ╠═══════════════════════════════════════════════════════════════════════════╣
  10. ║                                                                           ║
  11. ║                                 Credits                                   ║
  12. ║                                                                           ║
  13. ║                             Themie Gouthas                                ║
  14. ║                                                                           ║
  15. ║                            Matthew MacKenzie                              ║
  16. ║                                                                           ║
  17. ║                             Tore Bastiansen                               ║
  18. ║                                                                           ║
  19. ║                                 Andy Tam                                  ║
  20. ║                                                                           ║
  21. ║                               Douglas Webb                                ║
  22. ║                                                                           ║
  23. ║                              John  Schlagel                               ║
  24. ║                                                                           ║
  25. ╠═══════════════════════════════════════════════════════════════════════════╣
  26. ║                                                                           ║
  27. ║           I informally reserve all rights to the code in XLIB             ║
  28. ║       Rights to contributed code is also assumed to be reserved by        ║
  29. ║                          the original authors.                            ║
  30. ║                                                                           ║
  31. ╚═══════════════════════════════════════════════════════════════════════════╝
  32.  
  33. ╔═══════════════════════════════════════════════════════════════════════════╗
  34. ║ XLA2 UNIT - Compression and archiving                                     ║
  35. ╚═══════════════════════════════════════════════════════════════════════════╝
  36.  
  37. The XLA2 unit implements a set of procedures and functions to handle XLA files.
  38. XLA stands for XLib Archive and is a very useful and powerful tool.
  39. Suppose you just have written a game with XLib that uses many sprites, fonts
  40. and bitmaps and you are loading all these resources from disk. This means the
  41. program's directory is cluttered with lots of files which may take up a lot
  42. of space. With XLA you can pack all of these files into one and extract them
  43. from within your program at runtime. XLA files are created with the XLARC
  44. program distributed with XLibPas2. Files inside an XLA file can be stored in
  45. two ways (for now) : uncompressed and compressed using a variation of the LZS
  46. algorithm. When extracting them, though, you don't have to worry about their
  47. format : the XLA2 routines will handle all the uncompression/unpacking for you.
  48.  
  49. The structure of an XLA file is as follows :
  50.  
  51.     Header
  52.         signature: array[0..3] of char= 'XLAS'
  53.         posdir   : longint            = The position of the archive's directory
  54.                         which is at the end of the file.
  55.         sizedir  : longint            = The number of files stored in the archive
  56.  
  57.         Files      : lots of bytes      = The files, stored sequentially
  58.                  :
  59.                  :
  60.                  :
  61.  
  62.         Directory : array[1..sizedir] of name : array[0..11] of char= The name
  63.             of the file
  64.         posfile  : position of the file in the archive
  65.         sizefile : the original size of the file
  66.         sizecomp : the compressed size of the file
  67.         algorithm: 0 ( No compression ) 1 ( LZS compression )}
  68. {$G+,N-,E-}
  69.  
  70.  
  71.  
  72. Interface
  73.  
  74. Uses
  75.     XMisc2, Dos;
  76.  
  77. Const
  78.     None = 0; {No compression : store only}
  79.     LZS  = 1; {LZS77 compression algorithm}
  80.     Best = 8; {Not Used}
  81. Type
  82.     XLAOutProcType = procedure( var Data; size : word );
  83.     XLAInProcType  = procedure( var Data; size : word; var actual : longint );
  84. Var
  85.     ModeUsed : word;
  86.     XLAOutProc : XLAOutProcType;
  87. { This procedure is called by the XLA decoding routines everytime a new
  88.     packet of data has been uncompressed. The data is stored in data and the
  89.     amount of data is stored in size. The procedure that is pointed at by
  90.     this variable must be declared far.}
  91.     XLAInProc  : XLAInProcType;
  92. { This procedure is called by the XLA encoding routines everytime a new
  93.     packet of data is requested. The data has to be stored in data and the
  94.     amount of data that has to be passed back is stored in size.
  95.     If size bytes can't be provided then the actual amount of data
  96.     transferred is put in actual. If there is no more data, then actual must
  97.     be set to 0. The procedure that is pointed at by this variable must be
  98.     declared far.}
  99.     ratio : integer;
  100. { This variable contains the compression ratio in % of the last file that
  101.     was added to the archive with XLAPut. The value is invalid if no files
  102.     have been added. }
  103. Function  XLZSSave( FName : string ) : boolean;
  104. {  Creates a standalone file with name FName. Calls XLAInProc. Returns true
  105.     if successful, false otherwise.}
  106. Function  XLZSLoad( FName : string ) : boolean;
  107. { Loads a standalone file with name FName. Calls XLAOutProc. Returns true if
  108.     successful, false otherwise.}
  109. procedure XPrintDir;
  110. { Used by XLArc. Displays the directory of the currently open archive}
  111. function  XCloseArchive : boolean;
  112. { This function has to be called when the program doesn't need to access the
  113.     XLA file any more. If the archive was opened with XCreateArchive or
  114.     XUpdateArchive the the XEndArchive function must be called instead,
  115.     otherwise the XLA file will be corrupt. Frees all the memory allocated to
  116.     the uncompression routines. Returns true if successful.}
  117. function  XUpdateArchive( filename : string ) : boolean;
  118. { Opens an already existing XLA file for writing/reading. Reads in the archive's
  119.     directory. Returns true if successful.}
  120. function  XOpenArchive( filename : string ) : boolean;
  121. { Opens an already existing XLA file for reading. Reads in the archive's
  122.     directory. Returns true if successful.}
  123. function  XLAGet( fname : string ) : boolean;
  124. { Extracts a file from the currently open archive. Calls XLAOutProc.
  125.     Returns true if successful.}
  126. function  XLAPut( fname : string; mode : word ) : boolean;
  127. { Adds a file to the currently open archive. Calls XLAInProc. Returns true
  128.     if successful. Mode can be either None or LZS.}
  129. function  XEndArchive : boolean;
  130. { This function has to be called when the program has finished creating or
  131.     updating an archive. It writes the archive's directory at the end of the
  132.     file and updates the header to reflect any changes. Frees all memory
  133.     allocated to the compression routines. Returns true if successful.}
  134. function  XCreateArchive( filename : string ) : boolean;
  135. { Creates an XLA file for writing. Writes a template header to disk.
  136.     Returns true if successful.}
  137. function  XLAGetFileInfo( fname : string; var origsize, compsize : longint; mode : word ) : boolean;
  138. { Collects information about a particular file in the archive. Origsize
  139.     contains the length of the uncompressed file. Compsize contains the size of
  140.     the compressed file. Mode contains the algorithm used to store the file.
  141.     Returns true if successful.}
  142. function  XLAFindFirst( pattern : string; var match : string ) : boolean;
  143. { Searches through the archive's directory for the first file matching pattern.
  144.     and returns it in match. pattern can contain * wildcards in the standard DOS
  145.     notation. It doesn't support ? wildcards. Returns true if successful.}
  146. function  XLAFindNext( var match : string ) : boolean;
  147. { Finds the next file matching the pattern given in a previous call to
  148.     XLAFindFirst and returns it in match. Returns true if successful.}
  149. Implementation
  150.  
  151. const
  152.     TableSize = 5003;
  153.     LargestCode = 4095;
  154.     NoCode = -1;
  155.     N           = 4096;
  156.     F           = 18;
  157.     THRESHOLD   = 2;
  158.     NUL         = N * 2;
  159.  
  160.     BUFSIZE = 1024;
  161.     InBufPtr  : WORD = BUFSIZE;
  162.     InBufSize : WORD = BUFSIZE;
  163.     OutBufPtr : WORD = 0;
  164.  
  165. Type
  166.     PWorkspace = ^TWorkspace;
  167.     TWorkspace = record
  168.         TextBuf : Array[0.. N + F - 2] OF byte;
  169.         Left,Mom:  Array [0..N] OF word;
  170.         Right: Array [0..N + 256] OF word;
  171.     end;
  172.  
  173.     THeader = record
  174.         sig : array[0..3] of char;
  175.         posdir, sizedir : longint;
  176.     end;
  177.  
  178.     TFile = record
  179.         name : array[0..11] of char;
  180.         posfile, sizefile, sizecomp : longint;
  181.         algorithm : word;
  182.     end;
  183.  
  184.     PXLADir = ^TXLADir;
  185.     TXLADir = record
  186.         item : TFile;
  187.         next : PXLADir;
  188.     end;
  189.  
  190. Var
  191.     XLAFile : File;
  192.     Header : THeader;
  193.     XLADir, CurrentDir : PXLADir;
  194.     TotalSize, BytesWritten : longint;
  195.  
  196.     printcount, height,
  197.     matchPos, matchLen,
  198.     lastLen, printPeriod : WORD;
  199.     opt : BYTE;
  200.     SearchPattern : string;
  201.  
  202.     Workspace : PWorkspace;
  203.  
  204.     codeBuf: Array [0..16] of BYTE;
  205.  
  206.     Inbuf,OutBuf : Array[0..PRED(BUFSIZE)] of BYTE;
  207.  
  208.     ArchiveOpen : boolean;
  209.  
  210. Procedure InitBuffers;
  211. var
  212.     tmp : ^byte;
  213. begin
  214.     while true do
  215.     begin
  216.         new( Workspace );
  217.         if ofs(Workspace^)<>0 then
  218.         begin
  219.             dispose( Workspace );
  220.             new( tmp );
  221.         end else break;
  222.     end;
  223. end;
  224.  
  225. Procedure CleanUp;
  226. begin
  227.     Dispose( Workspace );
  228. end;
  229.  
  230. procedure CleanUpAll;
  231. var
  232.     tmp : PXLADir;
  233. begin
  234.     while XLADir<>nil do
  235.     begin
  236.         tmp := XLADir^.next;
  237.         dispose( XLADir );
  238.         XLADir := tmp;
  239.     end;
  240.     CleanUp;
  241. end;
  242.  
  243.  
  244. Function MemoryReadChunk: word;
  245.  
  246. var
  247.     Actual : longint;
  248.  
  249. begin
  250.     XLAInProc( InBuf, BufSize, Actual );
  251.     TotalSize := TotalSize + Actual;
  252.     MemoryReadChunk := Actual;
  253. end;
  254.  
  255. Procedure MemoryGetc; Assembler;
  256. asm
  257.     push    bx
  258.     mov     bx, inBufPtr
  259.     cmp     bx, inBufSize
  260.     jb      @getc1
  261.     push    cx
  262.     push    dx
  263.     push    di
  264.     push    si
  265.     call    MemoryReadChunk
  266.     pop     si
  267.     pop     di
  268.     pop     dx
  269.     pop     cx
  270.     mov     inBufSize, ax
  271.     or      ax, ax
  272.     jz      @getc2
  273.     xor     bx, bx
  274. @getc1:
  275.     mov     al, [Offset InBuf + bx]
  276.     inc     bx
  277.     mov     inBufPtr, bx
  278.     pop     bx
  279.     clc
  280.     jmp     @end
  281. @getc2:
  282.     pop     bx
  283.     stc
  284. @end:
  285. end;
  286.  
  287. Function DiskReadChunk: word;
  288.  
  289. var
  290.     Actual : WORD;
  291.  
  292. begin
  293.     if Bufsize > TotalSize then
  294.         Actual := TotalSize
  295.     else
  296.         Actual := BufSize;
  297.     if Actual > 0 then BlockRead(XLAFile,InBuf,Actual);
  298.     TotalSize := TotalSize - Actual;
  299.     DiskReadChunk := Actual;
  300. end;
  301.  
  302. Procedure DiskGetc; Assembler;
  303. asm
  304.     push    bx
  305.     mov     bx, inBufPtr
  306.     cmp     bx, inBufSize
  307.     jb      @getc1
  308.     push    cx
  309.     push    dx
  310.     push    di
  311.     push    si
  312.     call    DiskReadChunk
  313.     pop     si
  314.     pop     di
  315.     pop     dx
  316.     pop     cx
  317.     mov     inBufSize, ax
  318.     or      ax, ax
  319.     jz      @getc2
  320.     xor     bx, bx
  321. @getc1:
  322.     mov     al, [Offset InBuf + bx]
  323.     inc     bx
  324.     mov     inBufPtr, bx
  325.     pop     bx
  326.     clc
  327.     jmp     @end
  328. @getc2:
  329.     pop     bx
  330.     stc
  331. @end:
  332. end;
  333.  
  334. Procedure MemoryWriteout;
  335. begin
  336.     XLAOutProc( OutBuf, OutBufPtr );
  337.     BytesWritten := BytesWritten + OutBufPtr;
  338. end;
  339.  
  340. Procedure MemoryPutc; Assembler;
  341. asm
  342.     push    bx
  343.     mov     bx, outBufPtr
  344.     mov     [OFFSet OutBuf + bx], al
  345.     inc     bx
  346.     cmp     bx, BUFSIZE
  347.     jb      @putc1
  348.     mov     OutBufPtr,BUFSIZE
  349.     push    cx
  350.     push    dx
  351.     push    di
  352.     push    si
  353.     call    MemoryWriteOut
  354.     pop     si
  355.     pop     di
  356.     pop     dx
  357.     pop     cx
  358.     xor     bx, bx
  359. @putc1:
  360.     mov     outBufPtr, bx
  361.     pop     bx
  362. end;
  363.  
  364. Procedure DiskWriteout;
  365. var
  366.     Actual : WORD;
  367.  
  368. begin
  369.     BlockWrite(XLAFile,OutBuf,OutBufPtr,Actual);
  370.     BytesWritten := BytesWritten + OutBufPtr;
  371. end;
  372.  
  373. Procedure DiskPutc; Assembler;
  374. asm
  375.     push    bx
  376.     mov     bx, outBufPtr
  377.     mov     [OFFSet OutBuf + bx], al
  378.     inc     bx
  379.     cmp     bx, BUFSIZE
  380.     jb      @putc1
  381.     mov     OutBufPtr,BUFSIZE
  382.     push    cx
  383.     push    dx
  384.     push    di
  385.     push    si
  386.     call    DiskWriteOut
  387.     pop     si
  388.     pop     di
  389.     pop     dx
  390.     pop     cx
  391.     xor     bx, bx
  392. @putc1:
  393.     mov     outBufPtr, bx
  394.     pop     bx
  395. end;
  396.  
  397.  
  398. PROCEDURE LZSInitTree; Assembler;
  399. ASM
  400.     cld
  401.     les     ax, Workspace
  402.     mov     di, offset TWorkspace.Right
  403.     add     di, (N + 1) * 2
  404.     mov     cx, 256
  405.     mov     ax, NUL
  406.     rep     stosw
  407.     mov     di, offset TWorkspace.mom
  408.     mov     cx, N
  409.     rep     stosw
  410. END;
  411.  
  412.  
  413. PROCEDURE LZSSplay; Assembler;
  414. ASM
  415.     les     si, Workspace
  416. @Splay1:
  417.     mov     si, es:[Offset TWorkspace.Mom + di]
  418.     cmp     si, NUL
  419.     ja      @Splay4
  420.     mov     bx, es:[Offset TWorkspace.Mom + si]
  421.     cmp     bx, NUL
  422.     jbe     @Splay5
  423.     cmp     di, es:[Offset TWorkspace.Left + si]
  424.     jne     @Splay2
  425.     mov     dx, es:[Offset TWorkspace.Right + di]
  426.     mov     es:[Offset TWorkspace.Left + si], dx
  427.     mov     es:[Offset TWorkspace.Right + di], si
  428.     jmp     @Splay3
  429. @Splay2:
  430.     mov     dx, es:[Offset TWorkspace.Left + di]
  431.     mov     es:[Offset TWorkspace.Right + si], dx
  432.     mov     es:[Offset TWorkspace.Left + di], si
  433. @Splay3:
  434.     mov     es:[Offset TWorkspace.Right + bx], di
  435.     xchg    bx, dx
  436.     mov     es:[Offset TWorkspace.Mom + bx], si
  437.     mov     es:[Offset TWorkspace.Mom + si], di
  438.     mov     es:[Offset TWorkspace.Mom + di], dx
  439. @Splay4:
  440.     jmp     @end
  441. @Splay5:
  442.     mov     cx, es:[Offset TWorkspace.Mom + bx]
  443.     cmp     di, es:[Offset TWorkspace.Left + si]
  444.     jne     @Splay7
  445.     cmp     si, es:[Offset TWorkspace.Left + bx]
  446.     jne     @Splay6
  447.     mov     dx, es:[Offset TWorkspace.Right + si]
  448.     mov     es:[Offset TWorkspace.Left + bx], dx
  449.     xchg    bx, dx
  450.     mov     es:[Offset TWorkspace.Mom + bx], dx
  451.     mov     bx, es:[Offset TWorkspace.Right + di]
  452.     mov     es:[Offset TWorkspace.Left +si], bx
  453.     mov     es:[Offset TWorkspace.Mom + bx], si
  454.     mov     bx, dx
  455.     mov     es:[Offset TWorkspace.Right + si], bx
  456.     mov     es:[Offset TWorkspace.Right + di], si
  457.     mov     es:[Offset TWorkspace.Mom + bx], si
  458.     mov     es:[Offset TWorkspace.Mom + si], di
  459.     jmp     @Splay9
  460. @Splay6:
  461.     mov     dx, es:[Offset TWorkspace.Left + di]
  462.     mov     es:[Offset TWorkspace.Right + bx], dx
  463.     xchg    bx, dx
  464.     mov     es:[Offset TWorkspace.Mom + bx], dx
  465.     mov     bx, es:[Offset TWorkspace.Right + di]
  466.     mov     es:[Offset TWorkspace.Left + si], bx
  467.     mov     es:[Offset TWorkspace.Mom + bx], si
  468.     mov     bx, dx
  469.     mov     es:[Offset TWorkspace.Left + di], bx
  470.     mov     es:[Offset TWorkspace.Right + di], si
  471.     mov     es:[Offset TWorkspace.Mom + si], di
  472.     mov     es:[Offset TWorkspace.Mom + bx], di
  473.     jmp     @Splay9
  474. @Splay7:
  475.     cmp     si, es:[Offset TWorkspace.Right + bx]
  476.     jne     @Splay8
  477.     mov     dx, es:[Offset TWorkspace.Left + si]
  478.     mov     es:[Offset TWorkspace.Right + bx], dx
  479.     xchg    bx, dx
  480.     mov     es:[Offset TWorkspace.Mom + bx], dx
  481.     mov     bx, es:[Offset TWorkspace.Left + di]
  482.     mov     es:[Offset TWorkspace.Right + si], bx
  483.     mov     es:[Offset TWorkspace.Mom + bx], si
  484.     mov     bx, dx
  485.     mov     es:[Offset TWorkspace.Left + si], bx
  486.     mov     es:[Offset TWorkspace.Left + di], si
  487.     mov     es:[Offset TWorkspace.Mom + bx], si
  488.     mov     es:[Offset TWorkspace.Mom + si], di
  489.     jmp     @Splay9
  490. @Splay8:
  491.     mov     dx, es:[Offset TWorkspace.Right + di]
  492.     mov     es:[Offset TWorkspace.Left + bx], dx
  493.     xchg    bx, dx
  494.     mov     es:[Offset TWorkspace.Mom + bx], dx
  495.     mov     bx, es:[Offset TWorkspace.Left + di]
  496.     mov     es:[Offset TWorkspace.Right + si], bx
  497.     mov     es:[Offset TWorkspace.Mom + bx], si
  498.     mov     bx, dx
  499.     mov     es:[Offset TWorkspace.Right + di], bx
  500.     mov     es:[Offset TWorkspace.Left + di], si
  501.     mov     es:[Offset TWorkspace.Mom + si], di
  502.     mov     es:[Offset TWorkspace.Mom + bx], di
  503. @Splay9:
  504.     mov     si, cx
  505.     cmp     si, NUL
  506.     ja      @Splay10
  507.     cmp     bx, es:[Offset TWorkspace.Left + si]
  508.     jne     @Splay10
  509.     mov     es:[Offset TWorkspace.Left + si], di
  510.     jmp     @Splay11
  511. @Splay10:
  512.     mov     es:[Offset TWorkspace.Right + si], di
  513. @Splay11:
  514.     mov     es:[Offset TWorkspace.Mom + di], si
  515.     jmp     @Splay1
  516. @end:
  517. END;
  518.  
  519.  
  520. PROCEDURE LZSInsertNode; Assembler;
  521. ASM
  522.     les     ax, Workspace
  523.     push    si
  524.     push    dx
  525.     push    cx
  526.     push    bx
  527.     mov     dx, 1
  528.     xor     ax, ax
  529.     mov     matchLen, ax
  530.     mov     height, ax
  531.     mov     al, byte ptr es:[Offset TWorkspace.TextBuf + di]
  532.     shl     di, 1
  533.     add     ax, N + 1
  534.     shl     ax, 1
  535.     mov     si, ax
  536.     mov     ax, NUL
  537.     mov     word ptr es:[Offset TWorkspace.Right + di], ax
  538.     mov     word ptr es:[Offset TWorkspace.Left + di], ax
  539. @Ins1:
  540.     inc     height
  541.     cmp     dx, 0
  542.     jl      @Ins3
  543.     mov     ax, word ptr es:[Offset TWorkspace.Right + si]
  544.     cmp     ax, NUL
  545.     je      @Ins2
  546.     mov     si, ax
  547.     jmp     @Ins5
  548. @Ins2:
  549.     mov     word ptr es:[Offset TWorkspace.Right + si], di
  550.     mov     word ptr es:[Offset TWorkspace.Mom + di], si
  551.     jmp     @Ins11
  552. @Ins3:
  553.     mov     ax, word ptr es:[Offset TWorkspace.Left + si]
  554.     cmp     ax, NUL
  555.     je      @Ins4
  556.     mov     si, ax
  557.     jmp     @Ins5
  558. @Ins4:
  559.     mov     word ptr es:[Offset TWorkspace.Left + si], di
  560.     mov     word ptr es:[Offset TWorkspace.Mom + di], si
  561.     jmp     @Ins11
  562. @Ins5:
  563.     mov     bx, 1
  564.     shr     si, 1
  565.     shr     di, 1
  566.     xor     ch, ch
  567.     xor     dh, dh
  568. @Ins6:
  569.     mov     dl, byte ptr es:[Offset TWorkspace.TextBuf + di + bx]
  570.     mov     cl, byte ptr es:[Offset TWorkspace.TextBuf + si + bx]
  571.     sub     dx, cx
  572.     jnz     @Ins7
  573.     inc     bx
  574.     cmp     bx, F
  575.     jb      @Ins6
  576. @Ins7:
  577.     shl     si, 1
  578.     shl     di, 1
  579.     cmp     bx, matchLen
  580.     jbe     @Ins1
  581.     mov     ax, si
  582.     shr     ax, 1
  583.     mov     matchPos, ax
  584.     mov     matchLen, bx
  585.     cmp     bx, F
  586.     jb      @Ins1
  587. @Ins8:
  588.     mov     ax, word ptr es:[Offset TWorkspace.Mom + si]
  589.     mov     word ptr es:[Offset TWorkspace.Mom + di], ax
  590.     mov     bx, word ptr es:[Offset TWorkspace.Left + si]
  591.     mov     word ptr es:[Offset TWorkspace.Left + di], bx
  592.     mov     word ptr es:[Offset TWorkspace.Mom + bx], di
  593.     mov     bx, word ptr es:[Offset TWorkspace.Right + si]
  594.     mov     word ptr es:[Offset TWorkspace.Right + di], bx
  595.     mov     word ptr es:[Offset TWorkspace.Mom + bx], di
  596.     mov     bx, word ptr es:[Offset TWorkspace.Mom + si]
  597.     cmp     si, word ptr es:[Offset TWorkspace.Right + bx]
  598.     jne     @Ins9
  599.     mov     word ptr es:[Offset TWorkspace.Right + bx], di
  600.     jmp     @Ins10
  601. @Ins9:
  602.     mov     word ptr es:[Offset TWorkspace.Left + bx], di
  603. @Ins10:
  604.     mov     word ptr es:[Offset TWorkspace.Mom + si], NUL
  605. @Ins11:
  606.     cmp     height, 30
  607.     jb      @Ins12
  608.     call    LZSSplay
  609. @Ins12:
  610.     pop     bx
  611.     pop     cx
  612.     pop     dx
  613.     pop     si
  614.     shr     di, 1
  615. END;
  616.  
  617.  
  618. Procedure LZSDeleteNode; Assembler;
  619. asm
  620.     les     ax, Workspace
  621.     push    di
  622.     push    bx
  623.     shl     si, 1
  624.     cmp     word ptr es:[Offset TWorkspace.Mom + si], NUL
  625.     je      @del7
  626.     cmp     word ptr es:[Offset TWorkspace.Right + si], NUL
  627.     je      @del8
  628.     mov     di, word ptr es:[Offset TWorkspace.Left + si]
  629.     cmp     di, NUL
  630.     je      @del9
  631.     mov     ax, word ptr es:[Offset TWorkspace.Right + di]
  632.     cmp     ax, NUL
  633.     je      @del2
  634. @del1:
  635.     mov     di, ax
  636.     mov     ax, word ptr es:[Offset TWorkspace.Right + di]
  637.     cmp     ax, NUL
  638.     jne     @del1
  639.     mov     bx, word ptr es:[Offset TWorkspace.Mom + di]
  640.     mov     ax, word ptr es:[Offset TWorkspace.Left + di]
  641.     mov     word ptr es:[Offset TWorkspace.Right + bx], ax
  642.     xchg    ax, bx
  643.     mov     word ptr es:[Offset TWorkspace.Mom + bx], ax
  644.     mov     bx, word ptr es:[Offset TWorkspace.Left + si]
  645.     mov     word ptr es:[Offset TWorkspace.Left + di], bx
  646.     mov     word ptr es:[Offset TWorkspace.Mom + bx], di
  647. @del2:
  648.     mov     bx, word ptr es:[Offset TWorkspace.Right + si]
  649.     mov     word ptr es:[Offset TWorkspace.Right + di], bx
  650.     mov     word ptr es:[Offset TWorkspace.Mom + bx], di
  651. @del3:
  652.     mov     bx, word ptr es:[Offset TWorkspace.Mom + si]
  653.     mov     word ptr es:[Offset TWorkspace.Mom + di], bx
  654.     cmp     si, word ptr es:[Offset TWorkspace.Right + bx]
  655.     jne     @del4
  656.     mov     word ptr es:[Offset TWorkspace.Right + bx], di
  657.     jmp     @del5
  658. @del4:
  659.     mov     word ptr es:[Offset TWorkspace.Left + bx], di
  660. @del5:
  661.     mov     word ptr es:[Offset TWorkspace.Mom + si], NUL
  662. @del7:
  663.     pop     bx
  664.     pop     di
  665.     shr     si, 1
  666.     jmp     @end;
  667. @del8:
  668.     mov     di, word ptr es:[Offset TWorkspace.Left + si]
  669.     jmp     @del3
  670. @del9:
  671.     mov     di, word ptr es:[Offset TWorkspace.Right + si]
  672.     jmp     @del3
  673. @end:
  674. END;
  675.  
  676.  
  677. PROCEDURE LZSEncode; Assembler;
  678. ASM
  679.     call    LZSinitTree
  680.     les     bx, Workspace
  681.     xor     bx, bx
  682.     mov     [Offset CodeBuf + bx], bl
  683.     mov     dx, 1
  684.     mov     ch, dl
  685.     xor     si, si
  686.     mov     di, N - F
  687. @Encode2:
  688.     push    es
  689.     call    MemoryGetC
  690.     pop     es
  691.     jc      @Encode3
  692.     mov     byte ptr es:[Offset TWorkspace.TextBuf +di + bx], al
  693.     inc     bx
  694.     cmp     bx, F
  695.     jb      @Encode2
  696. @Encode3:
  697.     or      bx, bx
  698.     jne     @Encode4
  699.     jmp     @Encode19
  700. @Encode4:
  701.     mov     cl, bl
  702.     mov     bx, 1
  703.     push    di
  704.     sub     di, 1
  705. @Encode5:
  706.     push    es
  707.     call    LZSInsertNode
  708.     pop     es
  709.     inc     bx
  710.     dec     di
  711.     cmp     bx, F
  712.     jbe     @Encode5
  713.     pop     di
  714.     push    es
  715.     call    LZSinsertNode
  716.     pop     es
  717. @Encode6:
  718.     mov     ax, matchLen
  719.     cmp     al, cl
  720.     jbe     @Encode7
  721.     mov     al, cl
  722.     mov     matchLen, ax
  723. @Encode7:
  724.     cmp     al, THRESHOLD
  725.     ja      @Encode8
  726.     mov     matchLen, 1
  727.     or      byte ptr codeBuf, ch
  728.     mov     bx, dx
  729.     mov     al, byte ptr es:[Offset TWorkspace.TextBuf + di]
  730.     mov     byte ptr [Offset CodeBuf + bx], al
  731.     inc     dx
  732.     jmp     @Encode9
  733. @Encode8:
  734.     mov     bx, dx
  735.     mov     al, byte ptr matchPos
  736.     mov     byte ptr [Offset Codebuf + bx], al
  737.     inc     bx
  738.     mov     al, byte ptr (matchPos + 1)
  739.     push    cx
  740.     mov     cl, 4
  741.     shl     al, cl
  742.     pop     cx
  743.     mov     ah, byte ptr matchLen
  744.     sub     ah, THRESHOLD + 1
  745.     add     al, ah
  746.     mov     byte ptr [Offset Codebuf + bx], al
  747.     inc     bx
  748.     mov     dx, bx
  749. @Encode9:
  750.     shl     ch, 1
  751.     jnz     @Encode11
  752.     xor     bx, bx
  753. @Encode10:
  754.     mov     al, byte ptr [Offset CodeBuf + bx]
  755.     push    es
  756.     call    DiskPutC
  757.     pop     es
  758.     inc     bx
  759.     cmp     bx, dx
  760.     jb      @Encode10
  761.     mov     dx, 1
  762.     mov     ch, dl
  763.     mov     byte ptr codeBuf, dh
  764. @Encode11:
  765.     mov     bx, matchLen
  766.     mov     lastLen, bx
  767.     xor     bx, bx
  768. @Encode12:
  769.     push    es
  770.     call    MemoryGetC
  771.     pop     es
  772.     jc      @Encode14
  773.     push    ax
  774.     push    es
  775.     call    LZSdeleteNode
  776.     pop     es
  777.     pop     ax
  778.     mov     byte ptr es:[Offset TWorkspace.TextBuf + si], al
  779.     cmp     si, F - 1
  780.     jae     @Encode13
  781.     mov     byte ptr es:[Offset TWorkspace.TextBuf + si + N], al
  782. @Encode13:
  783.     inc     si
  784.     and     si, N - 1
  785.     inc     di
  786.     and     di, N - 1
  787.     push    es
  788.     call    LZSinsertNode
  789.     pop     es
  790.     inc     bx
  791.     cmp     bx, lastLen
  792.     jb      @Encode12
  793. @Encode14:
  794.     sub     printCount, bx
  795.     jnc     @Encode15
  796.     mov     ax, printPeriod
  797.     mov     printCount, ax
  798. @Encode15:
  799.     cmp     bx, lastLen
  800.     jae     @Encode16
  801.     inc     bx
  802.     push    es
  803.     call    LZSdeleteNode
  804.     pop     es
  805.     inc     si
  806.     and     si, N - 1
  807.     inc     di
  808.     and     di, N - 1
  809.     dec     cl
  810.     jz      @Encode15
  811.     push    es
  812.     call    LZSinsertNode
  813.     pop     es
  814.     jmp     @Encode15
  815. @Encode16:
  816.     cmp     cl, 0
  817.     jbe     @Encode17
  818.     jmp     @Encode6
  819. @Encode17:
  820.     cmp     dx, 1
  821.     jb      @Encode19
  822.     xor     bx, bx
  823. @Encode18:
  824.     mov     al, byte ptr [Offset Codebuf + bx]
  825.     push    es
  826.     call    DiskPutC
  827.     pop     es
  828.     inc     bx
  829.     cmp     bx, dx
  830.     jb      @Encode18
  831. @Encode19:
  832. end;
  833.  
  834.  
  835.  
  836. Procedure LZSDecode; Assembler;
  837. asm
  838.     les     dx, Workspace
  839.     xor     dx, dx
  840.     mov     di, N - F
  841. @Decode2:
  842.     shr     dx, 1
  843.     or      dh, dh
  844.     jnz     @Decode3
  845.     push    es
  846.     call    DiskGetC
  847.     pop     es
  848.     jc      @Decode9
  849.     mov     dh, 0ffh
  850.     mov     dl, al
  851. @Decode3:
  852.     test    dx, 1
  853.     jz      @Decode4
  854.     push    es
  855.     call    DiskGetC
  856.     pop     es
  857.     jc      @Decode9
  858.     mov     byte ptr es:[Offset TWorkspace.TextBuf + di], al
  859.     inc     di
  860.     and     di, N - 1
  861.     push    es
  862.     call    MemoryPutC
  863.     pop     es
  864.     jmp     @Decode2
  865. @Decode4:
  866.     push    es
  867.     call    DiskGetC
  868.     pop     es
  869.     jc      @Decode9
  870.     mov     ch, al
  871.     push    es
  872.     call    DiskGetC
  873.     pop     es
  874.     jc      @Decode9
  875.     mov     bh, al
  876.     mov     cl, 4
  877.     shr     bh, cl
  878.     mov     bl, ch
  879.     mov     cl, al
  880.     and     cl, 0fh
  881.     add     cl, THRESHOLD
  882.     inc     cl
  883. @Decode5:
  884.     and     bx, N - 1
  885.     mov     al, byte ptr es:[Offset TWorkspace.TextBuf + bx]
  886.     mov     byte ptr es:[Offset TWorkspace.TextBuf + di], al
  887.     inc     di
  888.     and     di, N - 1
  889.     push    es
  890.     call    MemoryPutC
  891.     pop     es
  892.     inc     bx
  893.     dec     cl
  894.     jnz     @Decode5
  895.     jmp     @Decode2
  896. @Decode9:
  897. END;
  898.  
  899. Function XLZSSave( FName : string ) : boolean;
  900. begin
  901.     if ArchiveOpen then
  902.     begin
  903.         XLZSSave := false;
  904.         exit;
  905.     end;
  906.     {$I-}
  907.     Assign( XLAFile, FName );
  908.     Rewrite( XLAFile, 1 );
  909.     {$I+}
  910.     if ioresult <> 0 then
  911.     begin
  912.         XLZSSave := false;
  913.         exit;
  914.     end;
  915.     InitBuffers;
  916.     InBufPtr    := BUFSIZE;
  917.     InBufSize   := BUFSIZE;
  918.     OutBufPtr   := 0;
  919.     printcount  := 0;
  920.     height      := 0;
  921.     matchPos    := 0;
  922.     matchLen    := 0;
  923.     lastLen     := 0;
  924.     printPeriod := 0;
  925.     opt         := 0;
  926.     TotalSize   := 0;
  927.     BytesWritten := 0;
  928.  
  929.     FillChar(Workspace^.TextBuf,N+F-1,0);
  930.     FillChar(Workspace^.Left,(N+1)*2,0);
  931.     FillChar(Workspace^.Mom,(N+1)*2,0);
  932.     FillChar(Workspace^.Right,(N+256)*2,0);
  933.     FillChar(codeBuf,Sizeof(codebuf),0);
  934.  
  935.     LZSencode;
  936.     DiskWriteOut;
  937.     Close( XLAFile );
  938.     CleanUp;
  939.     XLZSSave := true;
  940. END;
  941.  
  942. function XLZSLoad( FName : string ) : boolean;
  943. begin
  944.     if ArchiveOpen then
  945.     begin
  946.         XLZSLoad := false;
  947.         exit;
  948.     end;
  949.     {$I-}
  950.     assign( XLAFile, Fname );
  951.     reset( XLAFile, 1 );
  952.     {$I+}
  953.     if ioresult <> 0 then
  954.     begin
  955.         XLZSLoad := false;
  956.         exit;
  957.     end;
  958.     TotalSize := filesize( XLAFile );
  959.     InitBuffers;
  960.     InBufPtr  := BUFSIZE;
  961.     InBufSize := BUFSIZE;
  962.     OutBufPtr := 0;
  963.     FillChar(Workspace^.TextBuf,N+F-1,0);
  964.     BytesWritten := 0;
  965.     LZSdecode;
  966.     MemoryWriteOut;
  967.     close(XLAFile);
  968.     CleanUp;
  969.     XLZSLoad := true;
  970. end;
  971.  
  972. procedure AddName( var P, Q : PXLADir );
  973. begin
  974.     if P<>nil then
  975.         AddName( P^.next, Q )
  976.     else
  977.         P := Q;
  978. end;
  979.  
  980. function XCreateArchive( filename : string ) : boolean;
  981. var
  982.     sig : string[4];
  983. begin
  984.     {$I-}
  985.     assign( XLAFile, filename );
  986.     rewrite( XLAFile, 1 );
  987.     {$I+}
  988.     if ioresult <> 0 then
  989.     begin
  990.         XCreateArchive := false;
  991.         exit;
  992.     end;
  993.     sig := 'XLAS';
  994.     move( sig[1], Header.sig, 4 );
  995.     Header.posdir := sizeof(THeader);
  996.     Header.sizedir := 0;
  997.     blockwrite( XLAFile, Header, SizeOf(THeader) );
  998.     XLADir := nil;
  999.     XCreateArchive := true;
  1000.     InitBuffers;
  1001.     ArchiveOpen := true;
  1002. end;
  1003.  
  1004. function XEndArchive : boolean;
  1005. var
  1006.     tmp : PXLADir;
  1007. begin
  1008.     if not ArchiveOpen then
  1009.     begin
  1010.         XEndArchive := false;
  1011.         exit;
  1012.     end;
  1013.     seek(XLAFile, header.posdir);
  1014.     tmp := XLADir;
  1015.     while tmp<>nil do
  1016.     begin
  1017.         blockwrite( XLAFile, tmp^.item, sizeof(TFile) );
  1018.         tmp := tmp^.next;
  1019.     end;
  1020.     seek( XLAFile, 0 );
  1021.     blockwrite( XLAFile, Header, SizeOf(THeader) );
  1022.     close( XLAFile );
  1023.     CleanUpAll;
  1024.     ArchiveOpen := false;
  1025.     XEndArchive := true;
  1026. end;
  1027.  
  1028. function XLAGetFileInfo( fname : string; var origsize, compsize : longint; mode : word ) : boolean;
  1029. var
  1030.     tmp : PXLADir;
  1031.     name : array[0..11] of char;
  1032.     i : integer;
  1033. begin
  1034.     if not ArchiveOpen then
  1035.     begin
  1036.         XLAGetFileInfo := false;
  1037.         exit;
  1038.     end;
  1039.     for i := 1 to 12 do
  1040.         if i<=length( fname ) then
  1041.             name[i-1] := fname[i]
  1042.         else
  1043.             name[i-1] := ' ';
  1044.     tmp :=XLADir;
  1045.     if tmp = nil then
  1046.     begin
  1047.         XLAGetFileInfo := false;
  1048.         exit;
  1049.     end;
  1050.     while not xcompare( name, tmp^.item.name, 12 ) do
  1051.     begin
  1052.         if tmp^.next = nil then
  1053.         begin
  1054.             XLAGetFileInfo := false;
  1055.             exit;
  1056.         end;
  1057.         tmp := tmp^.next;
  1058.     end;
  1059.     origsize := tmp^.item.sizefile;
  1060.     compsize := tmp^.item.sizecomp;
  1061.     mode := tmp^.item.algorithm;
  1062.     XLAGetFileInfo := true;
  1063. end;
  1064.  
  1065. function XLAPut( fname : string; mode : word ) : boolean;
  1066. var
  1067.     tmp : PXLADir;
  1068.     i : integer;
  1069. begin
  1070.     if not ArchiveOpen then
  1071.     begin
  1072.         XLAPut := false;
  1073.         exit;
  1074.     end;
  1075.     inc( Header.sizedir );              { Increment size of directory }
  1076.     new( tmp );
  1077.     tmp^.next := nil;
  1078.     tmp^.item.posfile := Header.posdir;
  1079.     for i := 1 to 12 do
  1080.         if i <= length( fname ) then
  1081.             tmp^.item.name[i-1] := fname[i]
  1082.         else
  1083.             tmp^.item.name[i-1] := ' ';
  1084.  
  1085.     InBufPtr    := bufsize;
  1086.     Inbufsize   := bufsize;
  1087.     OutBufPtr   := 0;
  1088.     printcount  := 0;
  1089.     height      := 0;
  1090.     matchPos    := 0;
  1091.     matchLen    := 0;
  1092.     lastLen     := 0;
  1093.     printPeriod := 0;
  1094.     opt         := 0;
  1095.     TotalSize   := 0;
  1096.     BytesWritten := 0;
  1097.  
  1098.     FillChar(Workspace^.TextBuf,N+F-2,0);
  1099.     FillChar(Workspace^.Left,(N+1)*2,0);
  1100.     FillChar(Workspace^.Mom,(N+1)*2,0);
  1101.     FillChar(Workspace^.Right,(N+256)*2,0);
  1102.     FillChar(codeBuf,Sizeof(codebuf),0);
  1103.     seek( XLAFile, Header.posdir );
  1104.     case mode of
  1105.         None :
  1106.             begin
  1107.                 XLAInProc( OutBuf, BufSize, TotalSize );
  1108.                 while TotalSize > 0 do
  1109.                 begin
  1110.                     blockwrite(XLAFile, OutBuf, TotalSize );
  1111.                     BytesWritten := BytesWritten+TotalSize;
  1112.                     XLAInProc( OutBuf, BufSize, TotalSize );
  1113.                 end;
  1114.                 TotalSize := BytesWritten;
  1115.                 ModeUsed := None;
  1116.             end;
  1117.         LZS  :
  1118.             begin
  1119.                 LZSencode;
  1120.                 DiskWriteOut;
  1121.                 ModeUsed := LZS;
  1122.             end;
  1123.     end;
  1124.     tmp^.item.sizefile := TotalSize;
  1125.     tmp^.item.sizecomp := BytesWritten;
  1126.     tmp^.item.algorithm := ModeUsed;
  1127.     ratio := 100-(100*BytesWritten div TotalSize);
  1128.     Header.posdir := Header.posdir + BytesWritten;
  1129.     tmp^.next := nil;
  1130.     AddName( XLADir, tmp );
  1131.     XLAPut := true;
  1132. end;
  1133.  
  1134. function XLAGet( fname : string ) : boolean;
  1135. var
  1136.     i : integer;
  1137.     name : array[0..11] of char;
  1138.     tmp : PXLADir;
  1139. begin
  1140.     if not ArchiveOpen then
  1141.     begin
  1142.         XLAGet := false;
  1143.         exit;
  1144.     end;
  1145.     for i := 1 to 12 do
  1146.         if i<=length( fname ) then
  1147.             name[i-1] := fname[i]
  1148.         else
  1149.             name[i-1] := ' ';
  1150.  
  1151.     tmp := XLADir;
  1152.  
  1153.     while not( xcompare( name, tmp^.item.name, 12 ) ) do
  1154.     begin
  1155.         if tmp = nil then
  1156.         begin
  1157.             XLAGet := false;
  1158.             exit;
  1159.         end;
  1160.         tmp := tmp^.next;
  1161.     end;
  1162.     seek( XLAFile, tmp^.item.posfile );
  1163.     TotalSize := tmp^.item.sizecomp;
  1164.     InBufPtr  := bufsize;
  1165.     Inbufsize := bufsize;
  1166.     OutBufPtr := 0;
  1167.     FillChar(Workspace^.TextBuf,N+F-2,0);
  1168.     case tmp^.item.algorithm of
  1169.         None :
  1170.             begin
  1171.                 while TotalSize >0 do
  1172.                 begin
  1173.                     if TotalSize >= bufsize then
  1174.                         InBufSize := bufsize
  1175.                     else
  1176.                         InBufSize := TotalSize;
  1177.                     blockread( XLAFile, InBuf, InBufSize );
  1178.                     XLAOutProc( InBuf, InBufSize );
  1179.                     TotalSize := TotalSize - InBufSize;
  1180.                 end;
  1181.                 ModeUsed := None;
  1182.             end;
  1183.         LZS :
  1184.             begin
  1185.                 LZSdecode;
  1186.                 MemoryWriteOut;
  1187.                 ModeUsed := LZS;
  1188.             end;
  1189.     end;
  1190.     XLAGet := true;
  1191. end;
  1192.  
  1193. function XOpenArchive( filename : string ) : boolean;
  1194. var
  1195.     i : integer;
  1196.     tmp : PXLADir;
  1197.     sig : string[4];
  1198. begin
  1199.     if ArchiveOpen then
  1200.     begin
  1201.         XOpenArchive := false;
  1202.         exit;
  1203.     end;
  1204.     {$I-}
  1205.     assign( XLAFile, filename );
  1206.     FileMode := 0;
  1207.     reset( XLAFile, 1 );
  1208.     {$I+}
  1209.     FileMode := 2;
  1210.     if ioresult<>0 then
  1211.     begin
  1212.         XOpenArchive := false;
  1213.         exit;
  1214.     end;
  1215.     blockread( XLAFile, Header, sizeof(THeader) );
  1216.     sig := 'XLAS';
  1217.     if not xcompare( Header.sig,sig[1],4 ) then
  1218.     begin
  1219.         XOpenArchive := false;
  1220.         exit;
  1221.     end;
  1222.     InitBuffers;
  1223.     XLADir := nil;
  1224.     seek( XLAFile, Header.posdir );
  1225.     for i := 1 to Header.sizedir do
  1226.     begin
  1227.         new(tmp);
  1228.         blockread( XLAFile, tmp^.item, sizeof(TFile) );
  1229.         tmp^.next := nil;
  1230.         AddName(XLADir, tmp);
  1231.     end;
  1232.     ArchiveOpen := true;
  1233.     XOpenArchive := true;
  1234. end;
  1235.  
  1236. function XUpdateArchive( filename : string ) : boolean;
  1237. var
  1238.     i : integer;
  1239.     tmp : PXLADir;
  1240.     sig : string[4];
  1241. begin
  1242.     if ArchiveOpen then
  1243.     begin
  1244.         XUpdateArchive := false;
  1245.         exit;
  1246.     end;
  1247.     {$I-}
  1248.     assign( XLAFile, filename );
  1249.     FileMode := 2;
  1250.     reset( XLAFile, 1 );
  1251.     {$I+}
  1252.     if ioresult<>0 then
  1253.     begin
  1254.         XUpdateArchive := false;
  1255.         exit;
  1256.     end;
  1257.     blockread( XLAFile, Header, sizeof(THeader) );
  1258.     sig := 'XLAS';
  1259.     if not xcompare( Header.sig,sig[1],4 ) then
  1260.     begin
  1261.         XUpdateArchive := false;
  1262.         exit;
  1263.     end;
  1264.     InitBuffers;
  1265.     XLADir := nil;
  1266.     seek( XLAFile, Header.posdir );
  1267.     for i := 1 to Header.sizedir do
  1268.     begin
  1269.         new(tmp);
  1270.         blockread( XLAFile, tmp^.item, sizeof(TFile) );
  1271.         tmp^.next := nil;
  1272.         AddName(XLADir, tmp);
  1273.     end;
  1274.     seek( XLAFile, Header.posdir );
  1275.     truncate( XLAFile );
  1276.     ArchiveOpen := true;
  1277.     XUpdateArchive := true;
  1278. end;
  1279.  
  1280. function XCloseArchive : boolean;
  1281. begin
  1282.     if not ArchiveOpen then
  1283.         XCloseArchive := false
  1284.     else
  1285.     begin
  1286.         close( XLAFile );
  1287.         CleanUpAll;
  1288.         ArchiveOpen := false;
  1289.         XCloseArchive := true;
  1290.     end;
  1291. end;
  1292.  
  1293. procedure XPrintDir;
  1294. var
  1295.     tmp : PXLADir;
  1296.     s : string;
  1297.     totsize, totcomp : longint;
  1298. begin
  1299.     if not ArchiveOpen then exit;
  1300.     writeln('Name                Size       CSize   Ratio    Position  Method');
  1301.     writeln('----------------------------------------------------------------');
  1302.     tmp := XLADir;
  1303.     totsize := 0;
  1304.     totcomp := 0;
  1305.     while tmp <> nil do
  1306.     begin
  1307.         s[0] := #12;
  1308.         move( tmp^.item.name,s[1],12 );
  1309.         with tmp^.item do
  1310.         begin
  1311.             write( s:12,sizefile:12, sizecomp:12, 100-sizecomp*100/sizefile:8:2,
  1312.                 posfile:12);
  1313.             case algorithm of
  1314.                 None : writeln('  Stored');
  1315.                 LZS  : writeln('     LZS');
  1316.                 else   writeln(' Unknown');
  1317.             end;
  1318.             totsize := totsize + sizefile;
  1319.             totcomp := totcomp + sizecomp;
  1320.         end;
  1321.         tmp := tmp^.next;
  1322.     end;
  1323.     s := '';
  1324.     writeln('----------------------------------------------------------------');
  1325.     writeln( s:12, totsize:12, totcomp:12, 100-totcomp*100/totsize:8:2);
  1326. end;
  1327.  
  1328. function XLAFindNext( var match : string ) : boolean;
  1329. var
  1330.     d1, d2 : DirStr;
  1331.     n1, n2 : NameStr;
  1332.     e1, e2 : ExtStr;
  1333.     filename : PathStr;
  1334.     i : integer;
  1335.     wildname, wildext : byte;
  1336.     prefixname, prefixext : string[12];
  1337.     matchname, matchext : boolean;
  1338. begin
  1339.     FSplit( SearchPattern, d1, n1, e1 );
  1340.     wildname := pos( '*',n1 );
  1341.     wildext  := pos( '*',e1 );
  1342.     prefixname := copy( n1, 1, wildname-1 );
  1343.     prefixext  := copy( e1, 1, wildext-1 );
  1344.  
  1345.     while CurrentDir<>nil do
  1346.     begin
  1347.         move( CurrentDir^.item.name[0], filename[1], 12 );
  1348.         i := 0;
  1349.         while (i<=11) and ( CurrentDir^.item.name[i]<>' ') do
  1350.             inc(i);
  1351.         filename[0] := chr(i);
  1352.         FSplit( filename, d2, n2, e2 );
  1353.         if e2 ='' then e2 :='.';
  1354.         matchname := ((wildname=0) and (n1=n2)) or
  1355.                                  ((wildname>0) and (copy(n2,1,wildname-1)=prefixname));
  1356.         matchext  := ((wildext=0) and (e1=e2)) or
  1357.                                  ((wildext>0) and (copy(e2,1,wildext-1)=prefixext));
  1358.         if matchname and matchext then
  1359.         begin
  1360.             match := filename;
  1361.             CurrentDir := CurrentDir^.next;
  1362.             XLAFindNext := true;
  1363.             exit;
  1364.         end else
  1365.             CurrentDir := CurrentDir^.next;
  1366.     end;
  1367.     XLAFindNext := false;
  1368. end;
  1369.  
  1370. function XLAFindFirst( pattern : string; var match : string ) : boolean;
  1371. begin
  1372.     CurrentDir := XLADir;
  1373.     SearchPattern := pattern;
  1374.     XLAFindFirst := XLAFindNext( match );
  1375. end;
  1376.  
  1377. begin
  1378.     ArchiveOpen := false;
  1379.     XLADir := nil;
  1380. end.
  1381.